home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / eco30603.zip / ECO30603.LZH / ECO_CAL.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-08  |  11KB  |  315 lines
  1. (*
  2.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  3.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  4.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  5.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  6.     ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
  7.     ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
  8.     ▓▓▓▓▓▓▓▓   ECO_CAL was Conceived, Designed and Written      ░░▓▓▓▓▓▓▓▓▓
  9.     ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
  10.     ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
  11.     ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
  12.     ▓▓▓▓▓▓▓▓   (C) MCMXCII BY EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
  13.     ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
  14.     ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
  15.     ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
  16.     ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
  17.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  18.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  19.     ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  20. *)
  21. {$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
  22.  
  23. unit eco_cal;
  24.  
  25.  
  26. interface
  27.  
  28.  
  29.   procedure calendaraction;
  30.  
  31.  
  32.  
  33. implementation
  34.  
  35.  
  36.  
  37.  
  38.   procedure calendaraction;
  39.   const
  40.     maxyear = 2150;
  41.     minyear = 1850;
  42.   
  43.     c_72_spaties = '                                    ' +
  44.                    '                                    ';
  45.     c_8_spaties  = '        ';      c_wo  = '   WO   ';
  46.     c_zo         = '   ZO   ';      c_do  = '   DO   ';
  47.     c_ma         = '   MA   ';      c_vr  = '   VR   ';
  48.     c_di         = '   DI   ';      c_za  = '   ZA   ';
  49.   
  50.     c_jan        = ' JANUARI  ';    c_jul = '   JULI   ';
  51.     c_feb        = ' FEBRUARI ';    c_aug = ' AUGUSTUS ';
  52.     c_mrt        = '  MAART   ';    c_sep = 'SEPTEMBER ';
  53.     c_apr        = '  APRIL   ';    c_okt = ' OKTOBER  ';
  54.     c_mei        = '   MEI    ';    c_nov = ' NOVEMBER ';
  55.     c_jun        = '   JUNI   ';    c_dec = ' DECEMBER ';
  56.   
  57.   
  58.   type
  59.     t_c2  = packed array [1.. 2] of char;
  60.     t_c3  = packed array [1.. 3] of char;
  61.     t_c7  = packed array [1.. 7] of char;
  62.     t_c8  = packed array [1.. 8] of char;
  63.     t_c10 = packed array [1..10] of char;
  64.     t_c32 = packed array [1..32] of char;
  65.     t_c72 = packed array [1..72] of char;
  66.   
  67.     t_maandinfo  = packed record
  68.       voorloopspaties,
  69.       naloopspaties   : t_c3;
  70.       weekdagen       : packed array [0..5] of t_c3;
  71.     end;
  72.   
  73.     t_maandkop   = packed record
  74.       voorloopspaties    :  t_c7;
  75.       maandnaam          : t_c10;
  76.       naloopspaties      :  t_c7;
  77.     end;
  78.   
  79.     t_mogelijkheid = 1..4;
  80.     t_regel = packed record
  81.       weekdag                : t_c8;
  82.       case t_mogelijkheid of
  83.         1: ( regel_totaal    : t_c72);
  84.         2: ( voorloop        : t_c32;
  85.              jaartal         : t_c8;
  86.              naloop          : t_c32
  87.            );
  88.         3: ( kopregel        : packed array [1..3] of t_maandkop);
  89.         4: ( maandinfo       : packed array [1..3] of t_maandinfo);
  90.     end;
  91.   
  92.     t_e_maand = (
  93.       e_jan, e_feb, e_mrt, e_apr, e_mei, e_jun,
  94.       e_jul, e_aug, e_sep, e_okt, e_nov, e_dec
  95.     );
  96.   
  97.  
  98.   var
  99.     sunweekstart : boolean;
  100.     kalender     :    text;
  101.     kwartaal     : integer;
  102.     jaar         : integer;
  103.   
  104.     (*
  105.      * fuctie dagfactor is een oude bekende. deze functie is onder andere
  106.      * gebruikt in het programma datum --> weekdag conversie
  107.      * uit de 6502 kenner nr. 53. dit betrof toen een versie in c.
  108.      *
  109.      * het algoritme is afkomstig uit de programma rom van een ti 58
  110.      * rekenmachine.
  111.      *
  112.      * dagfactor berekent bij de ingevoerde dag, maand en jaar een dagnummer.
  113.      * dit dagnummer is uniek. door het dagnummer modulo 7 te nemen, krijgen
  114.      * we een getal dat de dag in de week aangeeft. hierbij krijgt de zondag
  115.      * de waarde nul. door voor de deling 1 van het dagnummer af te trekken,
  116.      * wordt er voor gezorgd dat de week begint op maandag.
  117.      *
  118.      * de datum wordt in waarde- (value) parameters doorgegeven, de dag in
  119.      * de week wordt als referentie- (reference) parameter teruggegeven dit wil
  120.      * zeggen dat bij de aanroep het startadres van de parameter doorgegeven
  121.      * wordt. deze variabele kan dus door dagfactor gewijzigd worden.
  122.      *
  123.      * als functieresultaat wordt doorgegeven of de ingevoerde datum bestaat
  124.      * en of het jaartal in het vastgestelde gebied ligt.
  125.      *)
  126.   
  127.   
  128.   
  129.   
  130.     function dagfactor(
  131.       p_dag         :   integer;
  132.       p_maand       : t_e_maand;
  133.       p_jaar        :   integer;
  134.       var p_weekdag :   integer
  135.     ): boolean;
  136.   
  137.     var
  138.       factor        : integer;
  139.       parameters_ok : boolean;
  140.       klad          : integer;
  141.   
  142.     begin
  143.       parameters_ok := (p_jaar >= minyear) and (p_jaar <= maxyear);
  144.       if parameters_ok then case p_maand of
  145.         e_jan,e_mrt,e_mei,e_jul,e_aug,e_okt,e_dec :
  146.           parameters_ok := (p_dag >= 1) and (p_dag <= 31);
  147.         e_apr,e_jun,e_sep,e_nov :
  148.           parameters_ok := (p_dag >= 1) and (p_dag <= 30);
  149.         e_feb :
  150.           if (
  151.             (p_jaar mod 4 = 0) and
  152.             (( p_jaar mod 100 <> 0) or ( p_jaar mod 400 = 0))
  153.           ) then parameters_ok := (p_dag >= 1) and (p_dag <= 29) else
  154.             parameters_ok := (p_dag >= 1) and (p_dag <= 28);
  155.       end;
  156.   
  157.       if parameters_ok then begin
  158.         klad := p_jaar - 1985 ;
  159.         factor := 365 * klad - 4 + p_dag + 31 * (ord(p_maand) - ord(e_jan));
  160.         if p_maand <= e_feb then begin
  161.           factor := factor +
  162.             (p_jaar - 1) div 4 - 3 * ((p_jaar - 1) div 100 + 1) div 4
  163.         end else begin
  164.           factor := factor -
  165.             (4 * (ord(p_maand) - ord(e_jan) + 1) + 23) div 10 +
  166.             p_jaar div 4 - 3 * (p_jaar div 100 + 1) div 4
  167.         end;
  168.         if sunweekstart then p_weekdag := (factor{ - 1}) mod 7 else
  169.           p_weekdag := (factor - 1) mod 7; { monday  day 0 }
  170.       end;
  171.       dagfactor := parameters_ok;
  172.     end;
  173.   
  174.   
  175.   
  176.   
  177.     procedure jaartal(p_jaar : integer);
  178.     var
  179.       regel : t_regel;
  180.       i     : integer;
  181.   
  182.     begin
  183.       if (p_jaar < minyear) or (p_jaar > maxyear) then begin
  184.         writeln('Year wrong', p_jaar);
  185.       end else with regel do begin
  186.         weekdag := c_8_spaties;
  187.         regel_totaal := c_72_spaties;
  188.         for i := 3 downto 0 do begin
  189.           jaartal[2 * i + 1] := chr((p_jaar mod 10) + ord('0'));
  190.           p_jaar := p_jaar div 10;
  191.         end;
  192.         writeln(weekdag, regel_totaal);
  193.         writeln(kalender, weekdag,regel_totaal);
  194.       end;
  195.     end;
  196.   
  197.   
  198.   
  199.   
  200.     procedure kopregel(p_kwartaal : integer);
  201.     var
  202.       regel : t_regel;
  203.   
  204.     begin
  205.       writeln;  writeln(kalender);
  206.       writeln;  writeln(kalender);
  207.       if (p_kwartaal < 1) or (p_kwartaal > 4) then begin
  208.         writeln('Quarterly wrong ',p_kwartaal);
  209.       end else with regel do begin
  210.         weekdag      := c_8_spaties;
  211.         regel_totaal := c_72_spaties;
  212.         case p_kwartaal of
  213.           1: begin
  214.             kopregel[1].maandnaam := c_jan;
  215.             kopregel[2].maandnaam := c_feb;
  216.             kopregel[3].maandnaam := c_mrt
  217.           end;
  218.           2: begin
  219.             kopregel[1].maandnaam := c_apr;
  220.             kopregel[2].maandnaam := c_mei;
  221.             kopregel[3].maandnaam := c_jun
  222.           end;
  223.           3: begin
  224.             kopregel[1].maandnaam := c_jul;
  225.             kopregel[2].maandnaam := c_aug;
  226.             kopregel[3].maandnaam := c_sep
  227.           end;
  228.           4: begin
  229.             kopregel[1].maandnaam := c_okt;
  230.             kopregel[2].maandnaam := c_nov;
  231.             kopregel[3].maandnaam := c_dec
  232.           end;
  233.         end;
  234.         writeln(weekdag,regel_totaal);
  235.         writeln(kalender,weekdag,regel_totaal)
  236.       end;
  237.       writeln; writeln(kalender)
  238.     end;
  239.   
  240.   
  241.   
  242.   
  243.     procedure dataregels(p_kwartaal, p_jaar: integer);
  244.     var
  245.       startdagen     : array [1..3] of integer;
  246.       maanden        : array [1..3] of t_e_maand;
  247.       i,j,k,i_weekdag: integer;
  248.       dag            : integer;
  249.       regel          : t_regel;
  250.   
  251.     begin
  252.       if (p_kwartaal >= 0) and (p_kwartaal <= 4) then begin
  253.         case p_kwartaal of
  254.           1: maanden[1] := e_jan;
  255.           2: maanden[1] := e_apr;
  256.           3: maanden[1] := e_jul;
  257.           4: maanden[1] := e_okt;
  258.         end;
  259.         maanden[2] := succ(maanden[1]); maanden[3] := succ(maanden[2]);
  260.         for i:= 1 to 3 do if not dagfactor(1,maanden[i],p_jaar,i_weekdag) then begin
  261.           writeln(kalender, 'error'); halt;
  262.         end else startdagen[i] := 1 - i_weekdag;
  263.         with regel do for k := 0 to 6 do begin
  264.           regel_totaal := c_72_spaties;
  265.           if sunweekstart then case k of
  266.             0: weekdag := c_zo;
  267.             1: weekdag := c_ma;
  268.             2: weekdag := c_di;
  269.             3: weekdag := c_wo;
  270.             4: weekdag := c_do;
  271.             5: weekdag := c_vr;
  272.             6: weekdag := c_za
  273.           end else case k of
  274.             0: weekdag := c_ma;
  275.             1: weekdag := c_di;
  276.             2: weekdag := c_wo;
  277.             3: weekdag := c_do;
  278.             4: weekdag := c_vr;
  279.             5: weekdag := c_za;
  280.             6: weekdag := c_zo
  281.           end;
  282.           for j := 1 to 3 do for i := 0 to 5 do begin
  283.             dag := startdagen[j] + 7 * i + k;
  284.             if dagfactor(dag,maanden[j],p_jaar,i_weekdag) then begin
  285.               maandinfo[j].weekdagen[i,3] := chr(dag mod 10 + ord('0'));
  286.               if dag >= 10 then maandinfo[j].weekdagen[i, 2] :=
  287.                 chr(dag div 10 + ord('0'));
  288.             end;
  289.           end;
  290.           writeln(weekdag,regel_totaal);
  291.           writeln(kalender,weekdag,regel_totaal);
  292.        end;
  293.       end;
  294.     end; { dataregels }
  295.   
  296.   
  297.   begin
  298.     sunweekstart := true;
  299.     assign(kalender, 'KALENDER.LIS');
  300.     rewrite(kalender);
  301.     repeat
  302.       write('Geef een jaartal j: ',minyear,' <= j <= ',maxyear,' : ');
  303.       readln(jaar);
  304.     until (jaar >= minyear) and (jaar <= maxyear);
  305.     jaartal(jaar);
  306.     for kwartaal := 1 to 4 do begin
  307.       kopregel(kwartaal); dataregels(kwartaal, jaar)
  308.     end;
  309.     close(kalender)
  310.   end; { proc action }
  311.  
  312.  
  313.  
  314. end. { unit }
  315.